R functions
library(tidyverse)
#> Warning: package 'tidyverse' was built under R version 4.2.1
#> ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.2 ──
#> ✔ ggplot2 3.3.6 ✔ purrr 0.3.4
#> ✔ tibble 3.1.8 ✔ dplyr 1.0.10
#> ✔ tidyr 1.2.1 ✔ stringr 1.4.1
#> ✔ readr 2.1.2 ✔ forcats 0.5.2
#> Warning: package 'ggplot2' was built under R version 4.2.1
#> Warning: package 'tibble' was built under R version 4.2.1
#> Warning: package 'tidyr' was built under R version 4.2.1
#> Warning: package 'readr' was built under R version 4.2.1
#> Warning: package 'dplyr' was built under R version 4.2.1
#> Warning: package 'stringr' was built under R version 4.2.1
#> Warning: package 'forcats' was built under R version 4.2.1
#> ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
#> ✖ dplyr::filter() masks stats::filter()
#> ✖ dplyr::lag() masks stats::lag()
# install.packages("plyr")
library(plyr)
#> Warning: package 'plyr' was built under R version 4.2.1
#> ------------------------------------------------------------------------------
#> You have loaded plyr after dplyr - this is likely to cause problems.
#> If you need functions from both plyr and dplyr, please load plyr first, then dplyr:
#> library(plyr); library(dplyr)
#> ------------------------------------------------------------------------------
#>
#> Attaching package: 'plyr'
#>
#> The following objects are masked from 'package:dplyr':
#>
#> arrange, count, desc, failwith, id, mutate, rename, summarise,
#> summarize
#>
#> The following object is masked from 'package:purrr':
#>
#> compact
# devtools::install_github("pavlakrotka/NCC@v1.0")
library(NCC)
#> Registered S3 methods overwritten by 'registry':
#> method from
#> print.registry_field proxy
#> print.registry_entry proxy
#> Warning: package 'memoise' was built under R version 4.2.1
source("C:/Users/mbofi/Dropbox/CeMSIIS/GitHub/Allocation/case-study/aux_functions.R")
We illustrate the optimal allocations in platform trials by means of a phase II placebo-controlled trial in primary hypercholesterolemia.
In the original study, \(N=92\) patients were randomised following 1:1:1.
# means
mean_control = 17.3/3.5
mean_arm1 = 66.2/3.5
mean_arm2 = 72.3/3.5
In what follows, we simulated the trial using the estimated mean in the control arm in the original study using three allocation strategies -namely, equal allocation (1:…:1), square root of \(k\) (1:…:\(\sqrt(k)\)), and the proposed optimal allocations-, and according to three different trial designs:
For comparative purposes, in this case study, we suppose total sample size of \(N=80\) and smaller effect sizes.
In this case, we consider a design with one period only. The scheme of the trial over time is:
db1_one = sim_designs(r1=1,r2=0,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="one")
db1_sqrt = sim_designs(r1=1,r2=0,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="sqrt")
db1_opt = sim_designs(r1=1,r2=0,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="opt")
plot_trial(db1_one$data$treatment)
Figure: Design 1: multi-arm design.
Distribution of sample sizes per arm and periods
# sample sizes
db1_one$ss
#> [,1] [,2] [,3]
#> [1,] 27 0 0
#> [2,] 27 0 0
#> [3,] 27 0 0
db1_sqrt$ss
#> [,1] [,2] [,3]
#> [1,] 23 0 0
#> [2,] 23 0 0
#> [3,] 33 0 0
db1_opt$ss
#> [,1] [,2] [,3]
#> [1,] 23 0 0
#> [2,] 23 0 0
#> [3,] 33 0 0
db1_one_ss <- data.frame(arms=c("A1","A2","C"),db1_one$ss, c(sum(db1_one$ss[1,]),sum(db1_one$ss[2,]),sum(db1_one$ss[3,])))
db1_sqrt_ss <- data.frame(arms=c("A1","A2","C"), db1_sqrt$ss, c(sum(db1_sqrt$ss[1,]),sum(db1_sqrt$ss[2,]),sum(db1_sqrt$ss[3,])))
db1_opt_ss <- data.frame(arms=c("A1","A2","C"), db1_opt$ss, c(sum(db1_opt$ss[1,]),sum(db1_opt$ss[2,]),sum(db1_opt$ss[3,])))
The sample sizes per arm and period according to the allocation strategies are the following:
knitr::kable(db1_one_ss, format = "markdown", caption = c("Sample sizes per period and arm (1:1)"), col.names = c("Arms", "Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 27 | 0 | 0 | 27 |
| A2 | 27 | 0 | 0 | 27 |
| C | 27 | 0 | 0 | 27 |
knitr::kable(db1_sqrt_ss, format = "markdown", caption = c("Sample sizes per period and arm (sqrt(k)-rule)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 23 | 0 | 0 | 23 |
| A2 | 23 | 0 | 0 | 23 |
| C | 33 | 0 | 0 | 33 |
knitr::kable(db1_opt_ss, format = "markdown", caption = c("Sample sizes per period and arm (optimal allocations)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 23 | 0 | 0 | 23 |
| A2 | 23 | 0 | 0 | 23 |
| C | 33 | 0 | 0 | 33 |
Comparing groups when using 1:1 allocation
res1_one = do.call(rbind.data.frame, models_cc(data = db1_one$data) )
knitr::kable(res1_one, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 12.68476 | 10.09121 | 15.27831 | TRUE | a1 |
| 0 | 14.86421 | 12.13642 | 17.59200 | TRUE | a2 |
Comparing groups when using \(\sqrt(k)\)-allocation (and thus optimal allocations)
res1_opt = do.call(rbind.data.frame, models_cc(data = db1_opt$data) )
knitr::kable(res1_opt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.20339 | 11.65083 | 16.75596 | TRUE | a1 |
| 0 | 15.50805 | 12.83460 | 18.18151 | TRUE | a2 |
N = 80
N1 = round(N/4)
N2 = round(N-N1)
c(N1,N2,N-N1-N2)
#> [1] 20 60 0
In this case, we consider a design with two periods. The scheme of the trial over time is:
db2_one=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="one")
db2_sqrt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="sqrt")
db2_opt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="opt")
plot_trial(db2_one$data$treatment)
Figure: Design 2: two-period design.
# sample sizes
db2_one$ss
#> [,1] [,2] [,3]
#> [1,] 0 20 0
#> [2,] 10 20 0
#> [3,] 10 20 0
db2_sqrt$ss
#> [,1] [,2] [,3]
#> [1,] 0 18 0
#> [2,] 10 18 0
#> [3,] 10 25 0
db2_opt$ss
#> [,1] [,2] [,3]
#> [1,] 0 24 0
#> [2,] 10 10 0
#> [3,] 10 26 0
db2_one_ss <- data.frame(arms=c("A1","A2","C"),db2_one$ss, c(sum(db2_one$ss[1,]),sum(db2_one$ss[2,]),sum(db2_one$ss[3,])))
db2_sqrt_ss <- data.frame(arms=c("A1","A2","C"), db2_sqrt$ss, c(sum(db2_sqrt$ss[1,]),sum(db2_sqrt$ss[2,]),sum(db2_sqrt$ss[3,])))
db2_opt_ss <- data.frame(arms=c("A1","A2","C"), db2_opt$ss, c(sum(db2_opt$ss[1,]),sum(db2_opt$ss[2,]),sum(db2_opt$ss[3,])))
The sample sizes per arm and period according to the allocation strategies are the following:
knitr::kable(db2_one_ss, format = "markdown", caption = c("Sample sizes per period and arm (1:1)"), col.names = c("Arms", "Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 20 | 0 | 20 |
| A2 | 10 | 20 | 0 | 30 |
| C | 10 | 20 | 0 | 30 |
knitr::kable(db2_sqrt_ss, format = "markdown", caption = c("Sample sizes per period and arm (sqrt(k)-rule)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 18 | 0 | 18 |
| A2 | 10 | 18 | 0 | 28 |
| C | 10 | 25 | 0 | 35 |
knitr::kable(db2_opt_ss, format = "markdown", caption = c("Sample sizes per period and arm (optimal allocations)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 24 | 0 | 24 |
| A2 | 10 | 10 | 0 | 20 |
| C | 10 | 26 | 0 | 36 |
Comparing groups when using 1:1 allocation
res2_one = do.call(rbind.data.frame, models_cc(data = db2_one$data) )
knitr::kable(res2_one, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.58389 | 13.14542 | 16.02237 | TRUE | a1 |
| 0 | 17.63898 | 15.10228 | 20.17567 | TRUE | a2 |
Comparing groups when using \(\sqrt(k)\)-allocation
res2_sqrt = do.call(rbind.data.frame, models_cc(data = db2_sqrt$data) )
knitr::kable(res2_sqrt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.74905 | 13.29103 | 16.20707 | TRUE | a1 |
| 0 | 14.27277 | 12.29935 | 16.24619 | TRUE | a2 |
Comparing groups when using the optimal allocations
res2_opt = do.call(rbind.data.frame, models_cc(data = db2_opt$data) )
knitr::kable(res2_opt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.64472 | 12.85768 | 16.43175 | TRUE | a1 |
| 0 | 17.73338 | 15.80459 | 19.66216 | TRUE | a2 |
Suppose now a design with three periods with \(N_1=31\) and consider two situations for \(N_2\), say \(N_2=N-N_1\) and \(N_2= N_1/2\).
Suppose now that the size of the periods are:
N1 = round(N/3)
N2 = round(N-2*N1)
c(N, N1, N2, N-N1-N2)
#> [1] 80 27 26 27
Note that in this case the duration of periods 1 and 3 is the same, leading to a symmetrical trial. Below we illustrate the scheme of the trial over time.
db3_one=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="one")
db3_sqrt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="sqrt")
db3_opt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="opt")
plot_trial(db3_opt$data$treatment)
Design 3: three-period design (r1=r3).
# sample sizes
db3_one$ss
#> [,1] [,2] [,3]
#> [1,] 0 9 13
#> [2,] 14 9 0
#> [3,] 14 9 13
db3_sqrt$ss
#> [,1] [,2] [,3]
#> [1,] 0 8 13
#> [2,] 14 8 0
#> [3,] 14 11 13
db3_opt$ss
#> [,1] [,2] [,3]
#> [1,] 0 8 13
#> [2,] 14 8 0
#> [3,] 14 11 13
db3_one_ss <- data.frame(arms=c("A1","A2","C"),db3_one$ss, c(sum(db3_one$ss[1,]),sum(db3_one$ss[2,]),sum(db3_one$ss[3,])))
db3_sqrt_ss <- data.frame(arms=c("A1","A2","C"), db3_sqrt$ss, c(sum(db3_sqrt$ss[1,]),sum(db3_sqrt$ss[2,]),sum(db3_sqrt$ss[3,])))
db3_opt_ss <- data.frame(arms=c("A1","A2","C"), db3_opt$ss, c(sum(db3_opt$ss[1,]),sum(db3_opt$ss[2,]),sum(db3_opt$ss[3,])))
The sample sizes per arm and period according to the allocation strategies are the following:
knitr::kable(db3_one_ss, format = "markdown", caption = c("Sample sizes per period and arm (1:1)"), col.names = c("Arms", "Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 9 | 13 | 22 |
| A2 | 14 | 9 | 0 | 23 |
| C | 14 | 9 | 13 | 36 |
knitr::kable(db3_sqrt_ss, format = "markdown", caption = c("Sample sizes per period and arm (sqrt(k)-rule)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 8 | 13 | 21 |
| A2 | 14 | 8 | 0 | 22 |
| C | 14 | 11 | 13 | 38 |
knitr::kable(db3_opt_ss, format = "markdown", caption = c("Sample sizes per period and arm (optimal allocations)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 8 | 13 | 21 |
| A2 | 14 | 8 | 0 | 22 |
| C | 14 | 11 | 13 | 38 |
Comparing groups when using 1:1 allocation
res3_one = do.call(rbind.data.frame, models_cc(data = db3_one$data) )
knitr::kable(res3_one, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 13.44103 | 12.30840 | 14.57366 | TRUE | a1 |
| 0 | 15.43635 | 14.16838 | 16.70432 | TRUE | a2 |
Comparing groups when using \(\sqrt(k)\)-allocation
res3_sqrt = do.call(rbind.data.frame, models_cc(data = db3_sqrt$data) )
knitr::kable(res3_sqrt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 13.51276 | 12.37502 | 14.65051 | TRUE | a1 |
| 0 | 15.96106 | 14.96704 | 16.95508 | TRUE | a2 |
Comparing groups when using the optimal allocations
res3_opt = do.call(rbind.data.frame, models_cc(data = db3_opt$data) )
knitr::kable(res3_opt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.69724 | 13.46913 | 15.92535 | TRUE | a1 |
| 0 | 15.05351 | 13.79869 | 16.30833 | TRUE | a2 |
Suppose now that the size of the periods are:
# N = 80
N1 = round(N/3)
N2 = round(2*(N-N1)/3)
c(N1,N2,N-N1-N2)
#> [1] 27 35 18
db3_one=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="one")
db3_sqrt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="sqrt")
db3_opt=sim_designs(r1=N1/N,r2=N2/N,mu0=mean_control,mu1=mean_arm1,mu2=mean_arm2,N=N,alloc="opt")
plot_trial(db3_opt$data$treatment)
Design 3: three-period design (r1<r3).
# sample sizes
db3_one$ss
#> [,1] [,2] [,3]
#> [1,] 0 12 9
#> [2,] 14 12 0
#> [3,] 14 12 9
db3_sqrt$ss
#> [,1] [,2] [,3]
#> [1,] 0 10 9
#> [2,] 14 10 0
#> [3,] 14 14 9
db3_opt$ss
#> [,1] [,2] [,3]
#> [1,] 0 13 9
#> [2,] 14 7 0
#> [3,] 14 15 9
db3_one_ss <- data.frame(arms=c("A1","A2","C"),db3_one$ss, c(sum(db3_one$ss[1,]),sum(db3_one$ss[2,]),sum(db3_one$ss[3,])))
db3_sqrt_ss <- data.frame(arms=c("A1","A2","C"), db3_sqrt$ss, c(sum(db3_sqrt$ss[1,]),sum(db3_sqrt$ss[2,]),sum(db3_sqrt$ss[3,])))
db3_opt_ss <- data.frame(arms=c("A1","A2","C"), db3_opt$ss, c(sum(db3_opt$ss[1,]),sum(db3_opt$ss[2,]),sum(db3_opt$ss[3,])))
The sample sizes per arm and period according to the allocation strategies are the following:
knitr::kable(db3_one_ss, format = "markdown", caption = c("Sample sizes per period and arm (1:1)"), col.names = c("Arms", "Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 12 | 9 | 21 |
| A2 | 14 | 12 | 0 | 26 |
| C | 14 | 12 | 9 | 35 |
knitr::kable(db3_sqrt_ss, format = "markdown", caption = c("Sample sizes per period and arm (sqrt(k)-rule)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 10 | 9 | 19 |
| A2 | 14 | 10 | 0 | 24 |
| C | 14 | 14 | 9 | 37 |
knitr::kable(db3_opt_ss, format = "markdown", caption = c("Sample sizes per period and arm (optimal allocations)"), col.names = c("Arms","Period 1","Period 2","Period 3", "Total per arm"))
| Arms | Period 1 | Period 2 | Period 3 | Total per arm |
|---|---|---|---|---|
| A1 | 0 | 13 | 9 | 22 |
| A2 | 14 | 7 | 0 | 21 |
| C | 14 | 15 | 9 | 38 |
Comparing groups when using 1:1 allocation
res3_one = do.call(rbind.data.frame, models_cc(data = db3_one$data) )
knitr::kable(res3_one, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 15.26003 | 14.21148 | 16.30857 | TRUE | a1 |
| 0 | 15.87749 | 14.71328 | 17.04171 | TRUE | a2 |
Comparing groups when using \(\sqrt(k)\)-allocation
res3_sqrt = do.call(rbind.data.frame, models_cc(data = db3_sqrt$data) )
knitr::kable(res3_sqrt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 14.89944 | 13.84920 | 15.94967 | TRUE | a1 |
| 0 | 16.23051 | 15.12429 | 17.33672 | TRUE | a2 |
Comparing groups when using the optimal allocations
res3_opt = do.call(rbind.data.frame, models_cc(data = db3_opt$data) )
knitr::kable(res3_opt, format = "markdown")
| p_val | treat_effect | lower_ci | upper_ci | reject_h0 | arm |
|---|---|---|---|---|---|
| 0 | 13.98791 | 12.78190 | 15.19392 | TRUE | a1 |
| 0 | 15.97735 | 14.67709 | 17.27760 | TRUE | a2 |
load("C:/Users/mbofi/Dropbox/CeMSIIS/GitHub/Allocation/case-study/results/simstudy_results.RData")
df_res$design = ifelse(as.numeric(df_res$r1)+as.numeric(df_res$r2)==1,"2-period", "3-period")
To compare power and type 1 error of the different designs, we undertake a simulation study to evaluate the performance when using 1:1 allocations. For comparative purposes, we also consider a total sample size for the trial equal to XX
res_report_H1 <- df_res %>% filter(H0=="FALSE") %>% select(minrt,rt_a1,rt_a2,r1,r2,alloc,design)
knitr::kable(res_report_H1, format = "markdown", caption = c("Power comparisons"), col.names=c("Min Power", "Power A1", "Power A2", "r1", "r2", "Allocation", "Design"))
| Min Power | Power A1 | Power A2 | r1 | r2 | Allocation | Design |
|---|---|---|---|---|---|---|
| 0.90015 | 0.93188 | 0.90015 | 0.3375 | 0.4375 | one | 3-period |
| 0.91773 | 0.91773 | 0.92704 | 0.3375 | 0.4375 | opt | 3-period |
| 0.91739 | 0.94009 | 0.91739 | 0.3375 | 0.4375 | sqrt | 3-period |
| 0.40323 | 0.71062 | 0.40323 | 0.25 | 0.75 | one | 2-period |
| 0.48907 | 0.6354 | 0.48907 | 0.25 | 0.75 | opt | 2-period |
| 0.40952 | 0.70559 | 0.40952 | 0.25 | 0.75 | sqrt | 2-period |
res_report_H0 <- df_res %>% filter(H0=="TRUE") %>% select(minrt,rt_a1,rt_a2,r1,r2,alloc,design)
knitr::kable(res_report_H0, format = "markdown", caption = c("Type 1 error rate"), col.names=c("Min T1E", "T1E A1", "T1E A2", "r1", "r2", "Allocation", "Design"))
| Min T1E | T1E A1 | T1E A2 | r1 | r2 | Allocation | Design |
|---|---|---|---|---|---|---|
| 0.0252 | 0.0252 | 0.02542 | 0.3375 | 0.4375 | one | 3-period |
| 0.0245 | 0.02456 | 0.0245 | 0.3375 | 0.4375 | opt | 3-period |
| 0.02396 | 0.02483 | 0.02396 | 0.3375 | 0.4375 | sqrt | 3-period |
| 0.02464 | 0.02464 | 0.02515 | 0.25 | 0.75 | one | 2-period |
| 0.02139 | 0.02139 | 0.02433 | 0.25 | 0.75 | opt | 2-period |
| 0.02425 | 0.02425 | 0.02471 | 0.25 | 0.75 | sqrt | 2-period |
Center for Medical Statistics, Informatics and Intelligent Systems, Medical University of Vienna.
[Klassifizierung: vertraulich]
marta.bofillroig@meduniwien.ac.at
and Martin Posch
martin.posch@meduniwien.ac.at